;;----------------------------------------------------------------------
;; Last Update:  5-Oct-96 by EHN
;;
;; Language Technologies Institute
;; 11-712 -- Self-Paced Laboratory
;; Algorithms for NLP
;;
;; Module 1: Bottom-Up Chart Parser -- Given Code
;;
;; Copyright (c) 1996, Carnegie Mellon University, All Rights Reserved.

;;----------------------------------------------------------------------
;; RULE
;;
;; Structure used to store grammar rules. 
;;
;; LHS: a non-terminal symbol
;; RHS: a list of non-terminal or lexical category symbols

(defstruct rule lhs rhs)

;;----------------------------------------------------------------------
;; ENTRY 
;;
;; Structure used to hold agenda/chart entries. 
;;
;; START: the starting position in the input
;; END: the ending position in the input,
;; CATEGORY: the lexical or non-terminal category
;; CHILDREN: the list of child node ids (for non-terminals only)
;; LEXEME: input symbol (lexical categories only)
;; ID: the unique integer identifier for each entry

(defstruct (entry (:print-function print-entry))
  start end category children lexeme id)

(defun print-entry (s stream depth)
  (declare (ignore depth))
  (prin1 (list (entry-start s) (entry-end s) (entry-category s)
	       (or (entry-lexeme s)(entry-children s)) (entry-id s))
	 stream))

;;----------------------------------------------------------------------
;; ARC
;;
;; Structure used to store active arcs. 
;;
;; START: the starting position in the input
;; END: the ending position in the input
;; INDEX: the offset (0-based) into the set of RHS symbols, equivalent
;;        to the position of Allen's circle mark
;; LHS: the LHS of the original rule
;; RHS: the RHS of the original rule
;; CHILDREN: a list of node ids (integers)

(defstruct arc start end index lhs rhs children)

;;----------------------------------------------------------------------
;; DEFRULE
;; 
;; Macro for easy rule definition (see examples below).

(defmacro defrule (lhs arrow &rest rhs)
  (declare (ignore arrow))
  `(make-rule :lhs ',lhs :rhs ',rhs))

;;----------------------------------------------------------------------
;; *GRAMMAR*
;; 
;; Global variable holding the grammar; a list of rule structures.

(defvar *grammar*)

;; Define the grammar.

(setq *grammar* 
      (list
       (defrule S -> NP VP)
       (defrule NP -> ART ADJ N)
       (defrule NP -> ART N)
       (defrule NP -> ADJ N)
       (defrule NP -> N)
       (defrule VP -> AUX VP)
       (defrule VP -> V NP)
       (defrule VP -> VP PP)
       (defrule NP -> NP PP)
       (defrule PP -> P NP)
       ))

;;----------------------------------------------------------------------
;; *LEXICON*
;;
;; Global variable holding the lexicon
;;
;; A list of lists, the first element of each list is the word and the
;; other elements are the entry-level non-terminals (lexical
;; categories) for each word in the grammar. 

(defvar *lexicon*)

;; Define the lexicon.

(setq *lexicon* '(
 (the art)
 (large adj)
 (can v aux n)
 (holds v)
 (water n)
 (man n)
 (in p)
))

;;----------------------------------------------------------------------
;; *PARSE-VALUE*
;;
;; Global variable to hold the last full parse trees.

(defvar *parse-value*)

;;----------------------------------------------------------------------
;; LOOKUP-WORD
;;
;; Lexical lookup function
;;
;; Given a word (a Lisp symbol from the parser's input), it returns a
;; list of symbols denoting the lexical categories for the word. If
;; the word doesn't have an entry, an error is signalled.

(defun lookup-word (word) 
  (or (rest (assoc word *lexicon*))
      (error "Unknown word: ~s" word)))

;;----------------------------------------------------------------------
;; *CHART-TRACE*
;;
;; Global variable which controls printing of trace messages
;;
;; Turned off by default.

(defvar *chart-trace* t)

;;----------------------------------------------------------------------
;; CHART-TRACE
;;
;; Tracing macro 
;;
;; Use where you would normally use FORMAT, i.e., (FORMAT T
;; ... becomes (CHART-TRACE ... 

(defmacro chart-trace (&rest args)
  `(when *chart-trace*
	 (format t ,@args)))

;;----------------------------------------------------------------------
;; *PRINT-PARSE-TREE*
;;
;; Global variable which controls printing of parse trees. 
;;
;; Turned on by default.

(defvar *print-parse-tree* t)

;;----------------------------------------------------------------------
;; RULES-STARTED-BY
;;
;; Function which returns a list of the grammar rules which are
;; started by the given constituent.

(defun rules-started-by (constituent)
  (remove-if-not #'(lambda (rule)
		     (and
		      ;; Constituent matches first element of RHS
		      (eq (first (rule-rhs rule)) constituent)
		      ;; There are other elements in the RHS to be found
		      (rest (rule-rhs rule))))
		 *grammar*))

;;----------------------------------------------------------------------
;; RULES-COMPLETED-BY
;;
;; Function which returns a list of the grammar rules which are
;; completed by the given constituent (only relevant for rules with a
;; single category in the RHS).

(defun rules-completed-by (constituent)
  (remove-if-not #'(lambda (rule)
		     (and
		      ;; Constituent matches first element of RHS
		      (eq (first (rule-rhs rule)) constituent)
		      ;; There are no other elements in the RHS to find
		      (null (rest (rule-rhs rule)))))
		 *grammar*))

;;----------------------------------------------------------------------
;; ARCS-CONTINUED-BY
;;
;; Function which returns a list of the active arcs ending at END
;; which are continued by the given constituent.

(defun arcs-continued-by (end constituent arcs)
  (remove-if-not #'(lambda (arc)
		     (and 
		      ;; Current end point of the arc matches the end
		      ;; point of the constituent.
		      (eq (arc-end arc) end)
		      ;; Constituent matches the next RHS symbol on
		      ;; the arc.
		      (eq (nth (arc-index arc) (arc-rhs arc))
			  constituent)
		      ;; There are more symbols on the arc RHS (so
		      ;; we're not completing the arc yet)
		      (nthcdr (1+ (arc-index arc)) (arc-rhs arc))))
		 arcs))

;;----------------------------------------------------------------------
;; ARCS-COMPLETED-BY
;;
;; Function which returns a list of the active arcs ending at END
;; which are completed by the given constituent.

(defun arcs-completed-by (end constituent arcs)
  (remove-if-not #'(lambda (arc)
		     (and 
		      ;; Current end point of the arc matches the end
		      ;; point of the constituent.
		      (eq (arc-end arc) end)
		      ;; Constitutent matches the next RHS symbol on
		      ;; the arc. 
		      (eq (nth (arc-index arc) (arc-rhs arc)) constituent)
		      ;; There are no more symbols on the arc RHS, so
		      ;; we're completing the arc.
		      (null (nthcdr (1+ (arc-index arc)) (arc-rhs arc)))))
		 arcs))

;;----------------------------------------------------------------------
;; INSERT-INDEX not used?
;;
;; Function to insert '*' into RHS to indicate index position for
;; rules or arcs.
;;
;; For printing purposes only -- equivalent to Allen's circle mark.

(defun insert-index (n list)
  (append (subseq list 0 n) (list '*) (subseq list n)))

;;----------------------------------------------------------------------
